COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 Answers to CS 206 Midterm
C00010 00003
C00011 ENDMK
C⊗;
; Answers to CS 206 Midterm
; May 3, 1977

(DEFUN LEAST (U) (LEEST (CAR U) (CDR U))) ; Compares first to rest

(DEFUN LEEST (WIN REST) ; Compares winner so far to the rest
       (COND ((NULL REST) WIN)
	     (T (LEEST (COND ((LESSP WIN (CAR REST)) WIN)
			     (T (CAR REST)))
		       (CDR REST))))) 

(DEFUN LEAST1 (X) ; Keeps winner of least of car vs. least of cdr
       (COND ((NUMBERP X) X)
	     (T ((LAMBDA (A D) (COND ((LESSP A D) A) (T D)))
		 (LEAST1 (CAR X))
		 (LEAST1 (CDR X)))))) 

(defun min-l (l); least written without an auxiliary function
  ((lambda (ans)
   (mapc (function (lambda (q) 
		    (cond ((lessp q ans)
			   (setq ans q))))) (cdr l))
   ans) (car l)))
 
; least1 written to compare first to rest
(defun min-x (x) (min-ex x (first-number x)))

(defun min-ex(x ans)
 (cond ((numberp x) x)
       (t 
	  (mapc (function (lambda (q)
		 ((lambda(a)
		  (cond ((lessp a ans)(setq ans a))))
	          (min-x q))))
	         x) ans)))
 
(defun first-number (l)
 (cond ((numberp l) l)
       (t (first-number (car l)))))
 
;Quotient written to do convential polynomial division, just like long division of numbers

(DEFUN QUOT (P1 P2) (REVERSE (QUOT1 (REVERSE P1) (REVERSE P2)))) 

(DEFUN QUOT1 (P1 P2) ; Does the division using lists with highest power first
       (COND ((LESSP (LENGTH P1) (LENGTH P2)) NIL)
	     (T ((LAMBDA (Q) 
			 (CONS Q
			       (QUOT1 (VDIFF (CDR P1)
					     (SCALPROD Q (CDR P2)))
				      P2)))
		 (DIV (CAR P1) (CAR P2)))))) 

(DEFUN VDIFF (U V) ;Takes the difference element by element of two lists
       (COND ((NULL U) (MAPCAR (FUNCTION MINUS) V)); invert sign and return 
	     ((NULL V) U)
	     (T (CONS (DIFFERENCE (CAR U) (CAR V))
		      (VDIFF (CDR U) (CDR V)))))) 

; Forces floating point arithmetic ... otherwise (quotient 4 3)=1
(DEFUN DIV (Q1 Q2) (QUOTIENT (PLUS Q1 0.0) (PLUS Q2 0.0))) 

(DEFUN SCALPROD (S V) ; Multiplies S times each element of V
       (MAPCAR (FUNCTION (LAMBDA (V1) (TIMES S V1))) V)) 

(DEFUN REM (P1 P2) (REVERSE (REM1 (REVERSE P1) (REVERSE P2)))) 

; Just like quot1 except throws away the quotient and keeps remainder
(DEFUN REM1 (P1 P2) 
       (COND ((LESSP (LENGTH P1) (LENGTH P2)) P1)
	     (T (REM1 (VDIFF (CDR P1)
			     (SCALPROD (DIV (CAR P1) (CAR P2))
				       (CDR P2)))
		      P2)))) 

;Frees uses auxiliaries to get rid of duplicates and to carry the list of bound variables
(DEFUN FREES (E) (REMOVDUPS (FREE1 E NIL))) 

(DEFUN FREE1 (E BOUND) ; Looks for any variable not in Bound
       (COND ((OR (NULL E) (EQ E T) (NUMBERP E)) NIL); Ignores constants
	     ((ATOM E) (COND ((MEMBER E BOUND) NIL) (T (LIST E)))); collects unbound vars
	     ((EQ 'GO (CAR E)) NIL); Ignores labels in GO statements
	     ((EQ 'LAMBDA (CAR E))  ; Collects bound vars whenever possible
	      (FREE1 (CDDR E) (APPEND (CADR E) BOUND)))
	     ((EQ 'DEFUN (CAR E))
	      (FREE1 (CDDDR E) (APPEND (CADDR E) BOUND)))
	     ((EQ 'PROG (CAR E)) ;Calls stripatoms to avoid labels in the PROG
	      (FREE1 (STRIPATOMS (CDDR E)) (APPEND (CADR E) BOUND)))
	     ((ATOM (CAR E)); Takes all the arguments of function but not fun name
	      (MAPCARAPP (FUNCTION FREE1) (CDR E) BOUND))
	     (T (MAPCARAPP (FUNCTION FREE1) E BOUND)))) ;Takes all elements of the list

; This is Map Car Append, like system function MAPCAN, but with extra arguments allowed
(DEFUN MAPCARAPP (FUN LISTARG ARG2) 
       (COND ((NULL LISTARG) NIL)
	     (T (APPEND (APPLY FUN (LIST (CAR LISTARG) ARG2))
			(MAPCARAPP FUN (CDR LISTARG) ARG2))))) 

(DEFUN REMOVDUPS (U) ; Gets rid of any element that occurs later in list
       (COND ((NULL U) NIL)
	     ((MEMBER (CAR U) (CDR U)) (REMOVDUPS (CDR U)))
	     (T (CONS (CAR U) (REMOVDUPS (CDR U)))))) 

; Returns all of list except atoms at top level (labels in this case)
(DEFUN STRIPATOMS (U) 
       (COND ((NULL U) NIL)
	     ((ATOM (CAR U)) (CDR U))
	     (T (CONS (CAR U) (STRIPATOMS (CDR U)))))) 



; You can also use a lambda in writing frees

(defun frees (l) (rem-dup (frees1 l nil)))

(defun frees1 (l bound)
 (cond 	((or (null l)(eq l t)(numberp l)) nil)
	((and (atom l) (not (memq l bound))) (ncons l))
	((atom l) nil)
	((eq (car l) 'defun)((lambda (bound)
				(mapcan (function
				 (lambda (q) (frees1 q bound))) (cdddr l)))
				(append (caddr l) bound)))
	((or (eq (car l) 'lambda)
	     (eq (car l) 'prog))
				((lambda (bound)
				 (mapcan (function
				  (lambda (q) (frees1 q bound)))(cddr l)))
				(append (cadr l) bound)))    
	((atom (car l))(mapcan (function 
				(lambda (q)(frees1 q bound))) (cdr l)))
	(t (mapcan (function
			(lambda (q) (frees1 q bound))) l))))
 
; Rem-dup uses memq, a version of member that tests with EQ rather than EQUAL
(defun rem-dup (l)
 (cond 	((null l) nil)
	((memq (car l)(cdr l))(rem-dup (cdr l)))
	(t (cons (car l)(rem-dup (cdr l))))))